home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / EGAVGA.SWG / 0176_Texture Mapping.pas < prev    next >
Pascal/Delphi Source File  |  1995-03-03  |  5KB  |  229 lines
  1. {
  2. Here is a "Perfect" texture mapper. It uses real number to map a square
  3. bitmap into a 4 point polygon. I haven't had any time to optimize it
  4. so I would love to see somebody speed it up for realtime uses. :)
  5. }
  6.  
  7. Program TextMap;
  8. {$N+,E+}   { Sorry all you out there :) }
  9.  
  10. Uses Crt;
  11.  
  12. Type
  13.   PointType = Record
  14.     X, Y : Integer;
  15.   End;
  16.  
  17. Const
  18.   Top = 1;    Bottom = 2; Left = 3; Right = 4; PWidth : Integer = 15;
  19.   PHeight : Integer = 15;
  20.  
  21.   Points : Array[0..3] of PointType = ((x : 100; y : 100),
  22.   (x : 150; y : 150),(x : 100; y : 200),(x : 50; y : 150));
  23.   BitMap : Array[0..15, 0..15] of Byte = ((1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1),
  24.       (1,5,5,5,5,5,5,5,5,5,5,5,5,5,5,1),(1,5,5,5,5,5,5,5,5,5,5,5,5,5,5,1),
  25.       (1,5,5,5,5,5,5,5,5,5,5,5,5,5,5,1),(1,5,5,5,5,5,5,5,5,5,5,5,5,5,5,1),
  26.       (1,5,5,5,5,1,1,1,1,1,1,5,5,5,5,1),(1,5,5,5,5,1,0,0,0,0,1,5,5,5,5,1),
  27.       (1,5,5,5,5,1,0,0,0,0,1,5,5,5,5,1),(1,5,5,5,5,1,0,0,0,0,1,5,5,5,5,1),
  28.       (1,5,5,5,5,1,0,0,0,0,1,5,5,5,5,1),(1,5,5,5,5,1,1,1,1,1,1,5,5,5,5,1),
  29.       (1,5,5,5,5,5,5,5,5,5,5,5,5,5,5,1),(1,5,5,5,5,5,5,5,5,5,5,5,5,5,5,1),
  30.       (1,5,5,5,5,5,5,5,5,5,5,5,5,5,5,1),(1,5,5,5,5,5,5,5,5,5,5,5,5,5,5,1),
  31.       (1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1));
  32.  
  33. Var
  34.   LeftTable, RightTable : Array[0..400, 0..2] of Integer;
  35.   Max_Y, Min_Y : Integer;
  36.   LineHeight : Integer;
  37.  
  38. Procedure PutPixel(X, Y : Integer; C : Byte);
  39.  
  40. Begin
  41.   Mem[$A000:(Y*320)+x] := c;
  42. End;
  43.  
  44. Procedure Swap(Var a, b : Integer);
  45.  
  46. Var
  47.   t : Integer;
  48.  
  49. Begin
  50.   t := a;
  51.   a := b;
  52.   b := t;
  53. End;
  54.  
  55. Procedure FindMaxMin;
  56.  
  57. Var
  58.   c : Integer;
  59.  
  60. Begin
  61.   For c := 0 to 3 do
  62.     Begin
  63.       If Points[c].Y < Min_y
  64.         Then Min_Y := Points[c].Y;
  65.       If Points[c].Y > Max_y
  66.         Then Max_Y := Points[c].Y;
  67.     End;
  68. End;
  69.  
  70.  
  71. Procedure ScanLeft(X1, X2, Y1, LH, Side : Integer);
  72.  
  73. Var
  74.   y : Integer;
  75.   XAdd, Px, Py, PxAdd, PyAdd, x : Single;
  76.  
  77. Begin
  78.   LH := LH + 1;
  79.   XAdd := (X2-X1)/LH;
  80.   If Side = Top
  81.     Then Begin
  82.       Px := PWidth;
  83.       Py := 0;
  84.       PxAdd := -PWidth/LH;
  85.       PyAdd := 0;
  86.     End;
  87.   If Side = Right
  88.     Then Begin
  89.       Px := PWidth;
  90.       Py := PHeight;
  91.       PxAdd := 0;
  92.       PyAdd := -PHeight/LH;
  93.     End;
  94.   If Side = Bottom
  95.     Then Begin
  96.       Px := 0;
  97.       Py := PHeight;
  98.       PxAdd := PWidth/LH;
  99.       PyAdd := 0;
  100.     End;
  101.   If Side = Left
  102.     Then Begin
  103.       Px := 0;
  104.       Py := 0;
  105.       PxAdd := 0;
  106.       PyAdd := PHeight/LH;
  107.     End;
  108.   x := X1;
  109.   For y := 0 to LH do
  110.     Begin
  111.       LeftTable[Y1 + y, 0] := Round(x);
  112.       LeftTable[Y1 + y, 1] := Round(Px);
  113.       LeftTable[Y1 + y, 2] := Round(Py);
  114.       X := X + XAdd;   Px := Px + PxAdd; Py := Py + PyAdd;
  115.     End;
  116. End;
  117.  
  118. Procedure ScanRight(X1, X2, Y1, LH, Side : Integer);
  119.  
  120. Var
  121.   y : Integer;
  122.   XAdd, Px, Py, PxAdd, PyAdd, x : Single;
  123.  
  124. Begin
  125.   LH := LH + 1;
  126.   XAdd := (X2-X1)/LH;
  127.   If Side = Top
  128.     Then Begin
  129.       Px := 0;
  130.       Py := 0;
  131.       PxAdd := PWidth/LH;
  132.       PyAdd := 0;
  133.     End;
  134.   If Side = Right
  135.     Then Begin
  136.       Px := PWidth;
  137.       Py := 0;
  138.       PxAdd := 0;
  139.       PyAdd := PHeight/LH;
  140.     End;
  141.   If Side = Bottom
  142.     Then Begin
  143.       Px := PWidth;
  144.       Py := PHeight;
  145.       PxAdd := 0;
  146.       PyAdd := -PHeight/LH;
  147.     End;
  148.   If Side = Left
  149.     Then Begin
  150.       Px := 0;
  151.       Py := PHeight;
  152.       PxAdd := 0;
  153.       PyAdd := -PHeight/LH;
  154.     End;
  155.   x := X1;
  156.   For y := 0 to LH do
  157.     Begin
  158.       RightTable[Y1 + y, 0] := Round(x);
  159.       RightTable[Y1 + y, 1] := Round(Px);
  160.       RightTable[Y1 + y, 2] := Round(Py);
  161.       X := X + XAdd;   Px := Px + PxAdd; Py := Py + PyAdd;
  162.     End;
  163. End;
  164.  
  165.  
  166. Procedure ScanConvert(X1, Y1, X2, Y2, PLoc : Integer);
  167.  
  168. Begin
  169.   If Y2 < Y1
  170.     Then Begin
  171.       Swap(X1, X2);
  172.       Swap(Y1, Y2);
  173.       LineHeight := Y2 - Y1;
  174.       ScanLeft(X1, X2, Y1, LineHeight, PLoc);
  175.     End
  176.     Else Begin
  177.       LineHeight := Y2 - Y1;
  178.       ScanRight(X1, X2, Y1, LineHeight, PLoc);
  179.     End;
  180. End;
  181.  
  182. Procedure TextureMap;
  183.  
  184. Var
  185.   LW, x, y : Integer;
  186.   PolyX1, PolyX2, Px1, Px2, Py1, Py2, PxA, PyA : Single;
  187.   Color : Byte;
  188.  
  189. Begin
  190.   For y := Min_Y to Max_Y do
  191.     Begin
  192.       PolyX1 := LeftTable[y,0];
  193.       Px1 := LeftTable[y,1];
  194.       Py1 := LeftTable[y,2];
  195.       PolyX2 := RightTable[y,0];
  196.       Px2 := RightTable[y,1];
  197.       Py2 := RightTable[y,2];
  198.       LW := Round(PolyX2-PolyX1);
  199.       Lw := Lw + 1;
  200.       PxA := (Px2-Px1)/LW;
  201.       PyA := (Py2-Py1)/LW;
  202.       For x := Round(PolyX1) to Round(PolyX2) do
  203.         Begin
  204.           Color := Bitmap[Round(Py1), Round(Px1)];
  205.           PutPixel(X, Y, Color);
  206.           Px1 := Px1 + PxA;
  207.           Py1 := Py1 + PyA;
  208.         End;
  209.     End;
  210. End;
  211.  
  212. Begin
  213.   Asm
  214.     Mov AX,$13
  215.     Int 10h
  216.   End;
  217.   Max_Y := 0;
  218.   Min_Y := 32000;
  219.   FindMaxMin;
  220.   ScanConvert(Points[0].X, Points[0].Y, Points[1].x, Points[1].y, Top);
  221.   ScanConvert(Points[1].X, Points[1].Y, Points[2].x, Points[2].y, Right);
  222.   ScanConvert(Points[2].X, Points[2].Y, Points[3].x, Points[3].y, Bottom);
  223.   ScanConvert(Points[3].X, Points[3].Y, Points[0].x, Points[0].y, Left);
  224.   TextureMap;
  225.   Readln;
  226.   TextMode(co80);
  227. End.
  228.  
  229.